perm filename INPOUT.SAI[PNT,HE]3 blob
sn#341265 filedate 1978-03-15 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00005 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 ENTRY
C00004 00003 ! saves on a file any tty input. The file can be managed only by AL_CLOSE
C00007 00004 ! input/output: altf,altrans,alframe,aldec,al_subtree,alid
C00012 00005 ! input/output: readexec,readcode,writecode,alfile,close,al_close
C00021 ENDMK
C⊗;
ENTRY;
BEGIN "INPOUT"
REQUIRE "MACROS.SAI[PNT,HE]"SOURCE_FILE;
REQUIRE "RECORD.DEF[PNT,HE]" SOURCE_FILE;
STRING ARRAY $NAMEFL[1:10] ; ! symbol table of files used;
INTEGER ARRAY $CHNFL[1:10,0:1]; ! open/closed and ch #;
EXTERNAL INTEGER $TOTFL; ! number of files defined;
EXTERNAL STRING $ALFL; ! last file used for output;
INTEGER $ALCH; ! $ALCH=channel used for output;
INTEGER $INPCH; ! channel # for input;
EXTERNAL BOOLEAN $OUT; ! if true output is required;
EXTERNAL STRING $TTYFL; ! name of file for tty input;
EXTERNAL INTEGER $TTYCH; ! channel # to output any tty input;
EXTERNAL STRING $OULST;
EXTERNAL STRING $BLANK;
EXTERNAL INTEGER $EOF,$BRCHR;
EXTERNAL INTEGER $ERRTAB,$BSKTAB;
EXTERNAL PROCEDURE ABORT1(STRING ERR1,ERR2(NULL));
EXTERNAL STRING PROCEDURE FRCVER(STRING FILE);
EXTERNAL PROCEDURE ESC_P;
EXTERNAL STRING PROCEDURE NAMEFILE; ! in PARSER.SAI;
EXTERNAL STRING $TAIL;
! in OUTPUT.SAI;
EXTERNAL SIMPLE STRING PROCEDURE CVGX(REAL R);
EXTERNAL SIMPLE STRING PROCEDURE STR_RT(REAL ARRAY XF;INTEGER NUM(1));
EXTERNAL SIMPLE STRING PROCEDURE STR_VT(REAL X,Y,Z;INTEGER NUM(1));
EXTERNAL SIMPLE STRING PROCEDURE STR_TR(REAL ARRAY XF;INTEGER ROT(1),VECT(1));
! saves on a file any tty input. The file can be managed only by AL_CLOSE;
! The AL_CLOSE instruction without parameters closes all open files and
asks for a new tty save file. Upon exit the file is automatically closed;
INTERNAL PROCEDURE TTYSAVE;
BEGIN
STRING ANSWER;
OUTSTR("file for TTY output=");ESC_P;
ANSWER←INCHWL; CLRBUF;
$TAIL←SCAN(ANSWER,$BSKTAB,$BRCHR); ! scan to eliminate $BLANK;
! reads from tail and return a file name;
IF $TAIL
THEN BEGIN
ANSWER←NAMEFILE;
OPEN($TTYCH←GETCHAN,"DSK",0,0,2,0,0,$EOF);
$EOF←-1;
ENTER($TTYCH,ANSWER,$EOF);
WHILE $EOF
DO BEGIN
PRINT("enter failed");
ANSWER←FRCVER(ANSWER);
ENTER($TTYCH,ANSWER,$EOF);
END;
$OUT←TRUE;
$TTYFL←ANSWER;
$OULST←NULL;
END
ELSE $OUT←FALSE;
END;
! returns a string with the names of files used for output and their
state (open/closed);
INTERNAL STRING PROCEDURE FILE_STRING;
BEGIN
INTEGER I;STRING TS;
TS←NULL;
FOR I←1 STEP 1 UNTIL $TOTFL
DO BEGIN
IF EQU($NAMEFL[I],$ALFL)
THEN TS←TS&"*"
ELSE TS←TS&" ";
TS←TS&"OC"[1+$CHNFL[I,0] FOR 1]&":"&$NAMEFL[I]&CRLF;
END;
RETURN(TS);
END;
! input/output: altf,altrans,alframe,aldec,al_subtree,alid;
! types on the file (open on $ALCH) the frame declaration and assignment
of affixment for the frame pointed by nd. If the frame is affixed
independently an assignment instruction is generated, otherwhise an
affix instruction, with the correct type of affixment is produced;
PROCEDURE ALDEC(RPTR(FRAME) ND);
BEGIN
STRING NAME,DS,FS;
NAME←FRAME:PNAME[ND]; ! frame pname;
DS←"FRAME "&NAME&";"&CRLF; ! declaration;
IF FRAME:HOWLINKED[ND]=#INDLK
THEN FS←NAME&" ← FRAME"&STR_TR(FRAME:XF[ND])&";"&DLF
ELSE BEGIN
FS←"AFFIX "&NAME&" TO "&FRAME:PNAME[FRAME:DAD[ND]]&" AT"
&CRLF&$BLANK[1 TO 6]&"TRANS"&STR_TR(FRAME:XF[ND]);
IF FRAME:HOWLINKED[ND]=#NRGLK
THEN FS←FS&" NONRIGIDLY;"&DLF
ELSE FS←FS&" RIGIDLY;"&DLF;
END;
CPRINT($ALCH,DS,FS);
END;
! finds the different frames looking at the frame tree;
RECURSIVE PROCEDURE FR_OUT(RPTR(FRAME) ND);
BEGIN
RPTR(FRAME) SN;
IF ND≠F_WRLD AND ND≠F_YARM AND ND≠F_BARM AND ND≠F_POINTER
AND ND≠F_BPARK AND ND≠F_YPARK AND ND≠F_FID AND ND≠F_BGRASP
THEN ALDEC(ND);
SN←FRAME:SON[ND];
WHILE SN≠NULL_RECORD
DO BEGIN
FR_OUT(SN);
SN←FRAME:EBRO[SN];
END;
END;
! types on the file (open on $ALCH) the scalar declarations and
assignments;
PROCEDURE ST_OUT(INTEGER TYPE);
BEGIN "U"
INTEGER ADDRIN,ADDRFN,I;
RPTR(SYMBOL)ADDR;STRING DS,VS;
ADDRIN←#LTYPE*(TYPE-#MIN); ! initial address in $YMTAB;
ADDRFN←$ENTRY[TYPE]-1; ! final address;
DS←VS←NULL;
FOR I←ADDRIN STEP 1 UNTIL ADDRFN DO
BEGIN "D"
ADDR←$YMTAB[I]; ! if null_record is a deleted symb;
IF ADDR≠NULL_RECORD
THEN CASE TYPE OF
BEGIN "CASE"
[#SC]
IF ADDR≠INCHES AND ADDR≠DEG AND ADDR≠HANDB AND ADDR≠HANDY
AND ADDR≠INCH AND ADDR≠DEGRES AND ADDR≠DEGREE
THEN BEGIN "SC"
DS←"SCALAR "&SYMBOL:PNAME[ADDR]&";"&CRLF;
VS←SYMBOL:PNAME[ADDR]&" ← "
&CVGX(SCALAR:VALUE[SYMBOL:OBJECT[ADDR]])&";"&DLF;
CPRINT($ALCH,DS,VS);
END "SC";
[#VT]
IF ADDR≠XHAT AND ADDR≠YHAT AND ADDR≠ZHAT AND ADDR≠NILVECT
THEN BEGIN "VT"
RPTR(VECTOR)IND;
IND←SYMBOL:OBJECT[ADDR];
DS←"DISTANCE VECTOR "&SYMBOL:PNAME[ADDR]&";"&CRLF;
VS←SYMBOL:PNAME[ADDR]&" ← "
&STR_VT(VECTOR:XC[IND],VECTOR:YC[IND],
VECTOR:ZC[IND]) &";"&DLF;
CPRINT($ALCH,DS,VS);
END "VT";
[#RT] IF ADDR≠NILROTN
THEN BEGIN "RT"
DS←"ROT "&SYMBOL:PNAME[ADDR]&";"&CRLF;
VS←SYMBOL:PNAME[ADDR]&" ← "
&STR_RT(ROT:XF[SYMBOL:OBJECT[ADDR]])&";"&DLF;
CPRINT($ALCH,DS,VS);
END "RT";
[#TR] IF ADDR≠NILTRANS
THEN BEGIN "TR"
DS←"TRANS "&SYMBOL:PNAME[ADDR]&";"&CRLF;
VS←SYMBOL:PNAME[ADDR]&" ← TRANS"
&STR_TR(TRANS:XF[SYMBOL:OBJECT[ADDR]])&";"&DLF;
CPRINT($ALCH,DS,VS);
END "TR"
END "CASE";
END "D";
END "U";
! input/output: readexec,readcode,writecode,alfile,close,al_close;
! if the file has been previously used returns its number in table,
otherwise returns 0;
INTERNAL INTEGER PROCEDURE ISFILE(STRING FILE);
BEGIN
INTEGER I;
FOR I←1 STEP 1 UNTIL $TOTFL DO
IF EQU($NAMEFL[I],FILE) THEN RETURN (I);
RETURN(0);
END;
SIMPLE PROCEDURE OPENFL(REFERENCE STRING FILE;INTEGER IND(0));
BEGIN
INTEGER ALEOF;
OPEN($ALCH←GETCHAN,"DSK",0,1,3,0,0,ALEOF);
ALEOF←-1;
ENTER($ALCH,FILE,ALEOF);
WHILE ALEOF
DO BEGIN
PRINT(" enter failed ");
FILE←FRCVER(FILE);
ENTER($ALCH,FILE,ALEOF);
END;
IF IND>0
THEN BEGIN
$CHNFL[IND,0]←0; ! file existent closed;
$CHNFL[IND,1]←$ALCH;
END
ELSE BEGIN
$TOTFL←$TOTFL+1; ! one new file;
$NAMEFL[$TOTFL]←FILE; ! name;
$CHNFL[$TOTFL,1]←$ALCH; ! channel number;
$CHNFL[$TOTFL,0]←0; ! file open;
END;
$OULST←NULL; ! file status modified;
END;
INTERNAL PROCEDURE FCLOSE;
BEGIN
INTEGER IND;
FOR IND←1 STEP 1 UNTIL $TOTFL DO
BEGIN
$CHNFL[IND,0]←1; ! sets the file closed in table;
PRINT("CLOSING ",$NAMEFL[IND],CRLF); ESC_P;
RELEASE($CHNFL[IND,1]); ! releases channels;
$ALFL←"DECLAR.AL"; ! new default file;
END;
IF $OUT
THEN BEGIN
PRINT("CLOSING ",$TTYFL,CRLF);ESC_P;
RELEASE($TTYCH,0); ! closes the tty save file;
$OUT←FALSE; ! sets the flag;
END;
END;
! close the file open;
INTERNAL PROCEDURE AL_CLOSE(STRING FILE );
BEGIN
INTEGER IND;
IND←ISFILE(FILE); ! address of file in table;
WHILE IND=0
DO BEGIN
PRINT("file not existent ");
FILE←FRCVER(FILE); ! recovers not existent file;
IND←ISFILE(FILE);
END;
$CHNFL[IND,0]←1; ! closes the file;
RELEASE($CHNFL[IND,1]);
! looks for an open file: if no file is open DECLAR.AL is proposed;
$ALFL←"DECLAR.AL";
IND←$TOTFL;
WHILE IND DO
IF $CHNFL[IND,0]
THEN IND←IND-1
ELSE BEGIN
$ALFL←$NAMEFL[IND]; ! name of open file;
DONE;
END;
$OULST←NULL; ! file status modified;
END;
INTERNAL PROCEDURE WRITECODE(STRING FILE;RPTR(FRAME) ROOT);
BEGIN
INTEGER IND;
! checks if file exists and if it's open, otherwise open it;
IND←ISFILE(FILE);
IF IND = 0
THEN OPENFL(FILE)
ELSE IF $CHNFL[IND,0]
THEN BEGIN
STRING STR;
PRINT("file existent, but closed (type Y to overwrite)");
STR←INCHRW;IF STR=CR THEN STR←INCHRW;
PRINT(CRLF);
IF STR="Y" OR str="y"
THEN OPENFL(FILE,IND)
ELSE ABORT1("not executed instruction");
END
ELSE $ALCH←$CHNFL[IND,1]; ! channel number;
! updates information for display;
IF NOT EQU(FILE,$ALFL)
THEN BEGIN
$ALFL←FILE; ! last file used for output;
$OULST←NULL;
END;
! output on the file;
IF ROOT=F_WRLD
THEN BEGIN ! complete output;
ST_OUT(#SC); ! outputs the scalars;
ST_OUT(#VT); ! outputs th vectors;
ST_OUT(#RT); ! outputs the rotations;
ST_OUT(#TR); ! outputs the transes;
END;
FR_OUT(ROOT); ! outputs the frame tree;
END;
PROCEDURE SAVE1(STRING FILE);
BEGIN
STRING OLDCNT;
CLOSO($ALCH); ! closes the file;
ENTER($ALCH,FILE,$EOF); ! enters the new file;
WHILE $EOF
DO BEGIN
PRINT("file not existent");
FILE←FRCVER(FILE);
ENTER($ALCH,FILE,$EOF);
END;
OPEN($INPCH←GETCHAN,"DSK",0,3,0,2000,$BRCHR,$EOF);
LOOKUP($INPCH,FILE,$EOF);
WHILE $EOF
DO BEGIN
PRINT("lookup failed for file ");
FILE←FRCVER(FILE);
LOOKUP($INPCH,FILE,$EOF);
END;
! the file is copied into the new file;
WHILE $EOF=0 DO
BEGIN
OLDCNT←INPUT($INPCH,0);
CPRINT($ALCH,OLDCNT);
END;
END;
INTERNAL PROCEDURE SAVECODE(STRING FILE;RPTR(FRAME)ROOT);
BEGIN
INTEGER IND,ALEOF;
IND←ISFILE(FILE); ! address of file in table;
IF IND=0
THEN BEGIN
WRITECODE(FILE,ROOT);
SAVE1(FILE);
END
ELSE IF $CHNFL[IND,0]=0
THEN BEGIN
$ALCH←$CHNFL[IND,1];
SAVE1(FILE);
END;
END;
INTERNAL PROCEDURE FSAVE; ! saves all open files;
BEGIN
INTEGER I;
FOR I←1 STEP 1 UNTIL $TOTFL DO
IF $CHNFL[I,0]=0
THEN BEGIN
$ALCH←$CHNFL[I,1];
SAVE1($NAMEFL[I]);
END;
IF $OUT
THEN BEGIN
$ALCH←$TTYCH;
SAVE1($TTYFL);
END;
END;
END "INPOUT";